\ SEE DECOMPILER FOR TURBOFORTH V1.2.1
\ MARK WILLS JANUARY 2014

FORGET _adr
0 VALUE _adr

: .addr| ( -- )
    CR _adr $. XY? SWAP 1- SWAP GOTOXY ." |" ;

: .str ( addr len -- )
    DUP XY? DROP + 1+ XMAX >= IF .addr| THEN TYPE SPACE ;

: .hex ( n -- )
    N>S DUP >R PAD SWAP CMOVE
    PAD R> .str ;

: .name ( lfa -- )
    >R R@ 2+ @ 15 AND  R> 4 + SWAP .str ;

: .type ( lfa -- is_forth )
    >CFA @ CASE
        $8320 OF ." Forth code" TRUE ENDOF
        $6FA4 OF ." VARIABLE or child of CREATE" FALSE ENDOF
        $7008 OF ." CONSTANT or VALUE" FALSE ENDOF
        DUP OF ." Machine code" FALSE ENDOF
    ENDCASE ;

: adr++ ( -- )
    [ 1 CELLS ] LITERAL +TO _adr ;

: getLIT ( -- n)
    adr++ _adr @ ;

: .LIT ( -- )
    getLIT .hex ;

: .(s) ( cfa -- )
    .addr| _adr @ >LINK .name
    _adr 2+ COUNT 2DUP >R >R
    OVER OVER + NIP SWAP DO I C@ EMIT LOOP 
    ASCII " EMIT SPACE 
    R> R> 3 + $FFFE AND +TO _adr DROP ;

: .header ( cfa -- is_forth )
    \ displays dictionary entry information on the word
    CR ." --- HEADER INFO ---"
    >LINK ( lfa) >R
    CR ."        Word: " R@ .name
    CR ."    Links to: " R@ @ .name ." at " R@ $.
    CR ." Code Starts: " R@ >CFA $.
    CR ."   Immediate: " R@ 2+ @ $8000 AND IF ." Yes" ELSE ." No" THEN
    CR ."    In Block: " R@ 2+ @ $3FF0 AND 4 >> DUP 0> IF 1+ THEN .
    CR ."        Type: " R> .type ;
    
: doDATA ( -- )
    adr++ 
    _adr @ 0 do
        getLIT .hex
    loop ;
    
: doDOES ( -- )
    [ 7 cells ] literal +TO _adr ;
    
: doTERM ( -- )
    getLIT getLIT .str ;
    
: doCompile ( -- )
    getLIT >LINK .name ;

\ we need more stack space to compile LOOKUP so save current stack address
\ in _adr for now, set stack to F800 then restore it afterwards...
SP@ TO _adr   $F800 SP!

: lookup ( addr -- )
    @ CASE
        \ headerless words:
              $8320 OF S" DOCOL"    .str            ENDOF
              $6086 OF S" LIT0"     .str            ENDOF
              $608C OF S" LIT1"     .str            ENDOF
              $6094 OF S" LIT8"     .str            ENDOF
              $609C OF S" LIT-1"    .str            ENDOF
              $7452 OF S" (ABORT)"  .str            ENDOF
              $60AC OF S" CLIT,"    .str            ENDOF
              $60B6 OF S" TOTERM:"  .str doTERM     ENDOF
              $655A OF S" (MARK)"   .str            ENDOF
              $6564 OF S" (AHEAD)"  .str            ENDOF
              $67BA OF S" REFUP"    .str            ENDOF
              $67C2 OF S" REFDN"    .str            ENDOF
              $6F4C OF S" (HEADER)" .str            ENDOF
              $6FB6 OF S" DOES>"    .str doDOES     ENDOF
              $7008 OF S" (DOCON)"  .str            ENDOF
              $708C OF S" TO_UTIL"  .str            ENDOF
              $7256 OF S" COMPILE"  .str doCompile  ENDOF
              $72B2 OF S" BLWORD"   .str            ENDOF
              $752C OF S" ERROR"    .str            ENDOF
              $78AC OF S" SIGNED"   .str            ENDOF
              $78B4 OF S" USIGNED"  .str            ENDOF
        ['] LIT     OF S" LIT"     2drop .LIT       ENDOF
        ['] BRANCH  OF S" BRANCH"   .str .LIT       ENDOF
        ['] 0BRANCH OF S" ZBRANCH"  .str .LIT       ENDOF
        ['] (DO)    OF S" (DO)"     .str adr++      ENDOF
        ['] (LOOP)  OF S" (LOOP)"   .str adr++      ENDOF
        ['] (+LOOP) OF S" (+LOOP)"  .str adr++      ENDOF
        ['] (+TO)   OF S" (+TO)"    .str adr++ _adr @ 2- >LINK .name ENDOF
        ['] (TO)    OF S" (TO)"     .str adr++ _adr @ 2- >LINK .name ENDOF
        ['] (S")    OF .(s)                         ENDOF
        ['] (DATA)  OF S" (DATA)"   .str doDATA     ENDOF
        DUP >LINK .name
    ENDCASE ;
\ now restore the stack to it's original location...
_adr SP!

: decompile ( cfa -- )
    TO _adr
    CR CR ." ADDR|DE-COMPILATION:"  .addr|
    begin
        _adr @ $832C <> WHILE
            _adr lookup adr++
    repeat 
    .addr| ." EXIT" ;

: .bytes ( n -- )
    ." ($" $. xy? swap 1- swap gotoxy ." ) bytes." ;

: see ( "name" -- )
    ' PAGE
    DUP 0= IF CR TRUE ABORT" Word not found in dictionary" THEN
    DUP TO _adr
    DUP .header ( is_forth) IF
        UNSIGNED @ >R   BASE @ >R  HEX
        TRUE UNSIGNED !
        DUP decompile
        R> BASE !   R> UNSIGNED !
        >R  CR CR ."        Code size: " _adr R@ - 2+ DUP . .bytes 
               CR ." Including header: " _adr R> >LINK - 2+ dup . .bytes 
    ELSE
        CR ." De-compilation not possible." DROP 
    THEN 
    CR ;
